Shareware Grab Bag/Shareware Grab Bag.iso/001/tmodem23.arc/TM1.INC

Text File | 1985-05-19 | 34.4 KB | 1,078 lines

(****************************************************************************)
(*                         EN-QUE SERIAL PORT INPUT &                       *)
(*                         DE-QUE SERIAL PORT OUTPUT                        *)
(*                             INTERRUPT DRIVEN                             *)
(****************************************************************************)
   procedure
      async_intr_handler;
   begin
      inline ($FB/$50/$53/$51/$52/$57/$56/$06/$1E);
      inline ($2E/$A1/datasegment
             /$8E/$D8);
      int_ident := port[int_ident_reg];
      repeat
         if int_ident = 4 then begin
            line_status := port[line_status_reg] and $1C;
            sin_buffer_ptr^[sin_store_ptr] := port[base_com_addr];
            if line_status = 0 then begin
               if ascii_mode then begin
                  if sin_buffer_ptr^[sin_store_ptr]=XOFF then
                     port[int_enable_reg] := 1;
                  if sin_buffer_ptr^[sin_store_ptr]=XON  then
                     port[int_enable_reg] := 3;
               end;
               if sin_store_ptr = sin_buf_size then
                  sin_store_ptr := 1
               else
                  sin_store_ptr := sin_store_ptr + 1;
               sin_buf_fill_cnt := sin_buf_fill_cnt + 1;
            end;
         end
         else begin
            if sout_store_ptr = sout_read_ptr then begin
               port[int_enable_reg] := 1;
               sout_int_off := true;
            end
            else begin
               port[base_com_addr] := sout_buffer_ptr^[sout_read_ptr];
               if sout_read_ptr = sout_buf_size then
                  sout_read_ptr := 1
               else
                  sout_read_ptr := sout_read_ptr + 1;
            end;
         end;
         int_ident := port[int_ident_reg];
      until int_ident = 1;
      port[$20] := $20;
      inline ($1F/$07/$5E/$5F/$5A/$59/$5B/$58/$5D/$5D/$CF);
   end;

(****************************************************************************)
(*                       EN-QUE SERIAL PORT OUTPUT                          *)
(****************************************************************************)
   procedure
      store_sout_buffer(ch : char);
   var
      new_sout_store_ptr   : integer;
      cnt                  : integer;
   begin
      if sout_store_ptr = sout_buf_size then
         new_sout_store_ptr := 1
      else
         new_sout_store_ptr := sout_store_ptr + 1;
      cnt := 0;
      while new_sout_store_ptr = sout_read_ptr do begin  { Wait for room }
         cnt := cnt + 1;                                 { in the queue. }
         if cnt > 40 then begin
            sout_store_ptr := sout_read_ptr;
            continue_transfer := false;
            sout_int_off := true;
            exit;
         end;
         delay( wait_increment );
      end;
      sout_buffer_ptr^[sout_store_ptr] := ord(ch);
      sout_store_ptr := new_sout_store_ptr;
      if sout_int_off then begin
         sout_int_off := false;
         port[int_enable_reg] := 3;
      end;
   end;

(****************************************************************************)
(*                        DE-QUE SERIAL PORT INPUT                          *)
(****************************************************************************)
   function
      read_sin_buffer : char;
   begin
      read_sin_buffer := chr(sin_buffer_ptr^[sin_read_ptr]);
      if sin_read_ptr = sin_buf_size then
         sin_read_ptr := 1
      else
         sin_read_ptr := sin_read_ptr + 1;
      sin_buf_fill_cnt := sin_buf_fill_cnt - 1;
      if sin_xoff then begin
         if sin_buf_fill_cnt < sin_buf_drain_lim then begin
            sin_xoff := false;
            store_sout_buffer( chr(xon) );
         end;
      end
      else begin
         if sin_buf_fill_cnt > sin_buf_fill_lim then begin
            sin_xoff := true;
            store_sout_buffer( chr(xoff) );
         end;
      end;
   end;

(****************************************************************************)
(*                           SETUP SERIAL PORT                              *)
(****************************************************************************)
   procedure
      setserial(baudrate,stopbits,databits,parity : integer);
   var
      parameter : integer;
      parn      : byte;
   begin
      case baudrate of
         300  : begin
                   baudrate:=2;
                   sync_time := wait_increment div 4;
                end;
         1200 : begin
                   baudrate:=4;
                   sync_time := wait_increment div 11;
                end;
         2400 : begin
                   baudrate:=5;
                   sync_time := wait_increment div 22;
                end;
         4800 : begin
                   baudrate:=6;
                   sync_time := (wait_increment div 44)+1;
                end;
         9600 : begin
                   baudrate:=7;
                   sync_time := (wait_increment div 88)+1;
                end;
      else
         baudrate:=4;                     { Default to 1200 baud }
         sync_time := wait_increment div 11;
      end;
      if stopbits=2 then
         stopbits:=1
      else
         stopbits:=0;                     { Default to 1 stop bit }
      parn := parity;
      if databits=7 then
         databits:=2
      else begin
         databits:=3;                     { Default to 8 data bits }
         parn:=0;
      end;
      parameter:=(baudrate shl 5)+(stopbits shl 2)+databits;
      case parn of
         1 : parameter:=parameter+24;
         2 : parameter:=parameter+8;
      end;
      regs.DX := 0;                       { 0 = COM1;   1 = COM2 }
      regs.AX := parameter;
      regs.FLAGS := 0;
      intr($14,regs);
      port[modem_control_reg] := $0B;
      port[$21] := port[$21] and turn_IRQ_on;
      port[int_enable_reg] := 1;
      sout_int_off := true;
   end;

(****************************************************************************)
(*                         DISPLAY PROMPTS LINE                             *)
(****************************************************************************)
   procedure
      clear_pos( i,j : integer );
   begin
      escape_win;
      textcolor( BGcolor );
      textbackground( FGcolor );
      gotoxy(i,j);
      write(' ');
      textcolor( FGcolor );
      textbackground( BGcolor );
      reset_win;
   end;

   procedure
      display_prompts;
   begin
      escape_win;
      textcolor( BGcolor );
      textbackground( FGcolor );
      gotoxy(1,25);
      clreol;
      write('   Alt: T=Terminate, R=Receive, X=Transmit, C=Capture, H=Help, S=Chg Params.   ');
      textcolor( FGcolor );
      textbackground( BGcolor );
      reset_win;
   end;

(****************************************************************************)
(*                         SAVE CAPTURE BUFFERS                             *)
(****************************************************************************)
   procedure
      save_capture_buffers;
   var
      r        : real;
   begin
      writeln;
      write(' Enter Filename for Capture Buffer Save: ');
      readln(filename);
      if length(filename)=0 then exit;
      assign(recv_file,filename);
      rewrite(recv_file);
      capture_curr := capture_first;
      repeat
         if capture_curr^.capture_store_ptr <= capture_buf_size then
            capture_curr^.capture_buffer[capture_curr^.capture_store_ptr] := ^Z
         else
            capture_curr^.capture_store_ptr := capture_buf_size;
         if capture_curr^.capture_store_ptr > 1 then begin
            r := (capture_curr^.capture_store_ptr / 128.0) + 0.999;
            blockwrite(recv_file,capture_curr^.capture_buffer,trunc(r));
         end;
         capture_curr := capture_curr^.capture_next;
      until capture_curr = nil;
      close(recv_file);
   end;

(****************************************************************************)
(*                      ENTER / LEAVE  CAPTURE MODE                         *)
(****************************************************************************)
   procedure
      toggle_capture_mode;
   begin
      if capture_flag then begin
         capture_flag := false;
         mkwin(11,8,67,14,'Exit Capture Mode');
         writeln;
         write(' Do you wish to save capture buffer? ');
         readln(yes_no);
         yes_no := upcase(yes_no[1]);
         if yes_no = 'Y' then
            save_capture_buffers;
         capture_curr := capture_first;
         repeat
            capture_first := capture_curr;
            capture_curr := capture_curr^.capture_next;
            dispose(capture_first);
         until capture_curr = nil;
         rmwin;
         clear_pos(1,25);
      end
      else begin
         capture_flag := true;
         capture_warning := false;
         escape_win;
         gotoxy(1,25);
         write('*');
         reset_win;
         new(capture_first);
         capture_curr := capture_first;
         capture_curr^.capture_store_ptr := 1;
         capture_curr^.capture_next := nil;
      end;
   end;

(****************************************************************************)
(*                          CAPTURE A CHARACTER                             *)
(****************************************************************************)
   procedure
      capture( c : char );
   begin
      capture_curr^.capture_buffer[capture_curr^.capture_store_ptr] := c;
      capture_curr^.capture_store_ptr := capture_curr^.capture_store_ptr + 1;
      if capture_curr^.capture_store_ptr > capture_buf_size then begin
         if memory < 6 then
            toggle_capture_mode
         else begin
            new(capture_curr^.capture_next);
            capture_curr := capture_curr^.capture_next;
            capture_curr^.capture_store_ptr := 1;
            capture_curr^.capture_next := nil;
            if (not capture_warning and (memory < 10)) then begin
               capture_warning := true;
               escape_win;
               gotoxy(1,25);
               write('W');
               reset_win;
            end;
         end;
      end;
   end;

(****************************************************************************)
(*                             PROCESS ESCAPE                               *)
(****************************************************************************)
   procedure
      prt_cap( c : char );
   begin
      if printer_on then write(lst,c);
      if capture_flag then capture( c );
   end;

   procedure
      horz_tab;
   var
      i,j  : byte;
   begin
      i := 8 - (wherex mod 8);
      for j:=1 to i do begin
         write( ' ' );
         prt_cap( ' ' );
      end;
   end;

   procedure
      wrt( var c : char );
   var
      i  : integer;
   begin
      i := ord( c );
      if ( i > 95 ) and line_drawing_chars then
         c := char(alt_character[i]);
      case c of
         NUL : exit;
         FF  : clrscr;
         TAB : begin
                  horz_tab;
                  exit;
               end;
      else
         write( c );
      end;
      prt_cap( c );
   end;

   procedure
      set_graphics;
   var
      i     : integer;
   begin
      for i:=1 to escape_number do begin
         case escape_register[i] of
            0 : begin
                   white_shade := lightgray;
                   FG := white_shade;
                   BG := black;
                end;
            1 : begin
                   white_shade := white;
                   FG := white_shade;
                end;
            4 : FG := blue;
            5 : FG := FG + blink;
            7 : begin
                   FG := BGcolor;
                   BG := FGcolor;
                end;
            8 : FG := BG;
           30 : FG := black;
           31 : FG := red;
           32 : FG := green;
           33 : FG := yellow;
           34 : FG := blue;
           35 : FG := magenta;
           36 : FG := cyan;
           37 : FG := white_shade;
           40 : BG := black;
           41 : BG := red;
           42 : BG := green;
           43 : BG := yellow;
           44 : BG := blue;
           45 : BG := magenta;
           46 : BG := cyan;
           47 : BG := white_shade;
         end;
      end;
      textcolor( FG );
      textbackground( BG );
   end;

   procedure
      addr_cursor;
   begin
      if escape_number=1       then escape_register[2]:=1;
      if escape_register[1]=0  then escape_register[1]:=1;
      if escape_register[1]=25 then escape_register[1]:=24;
      gotoxy(escape_register[2],escape_register[1]);
   end;

   procedure
      cursor_up;
   var
      my  : integer;
   begin
      if escape_register[1]=0 then escape_register[1]:=1;
      my := wherey - escape_register[1];
      gotoxy(wherex,my);
   end;

   procedure
      cursor_down;
   var
      my  : integer;
   begin
      if escape_register[1]=0 then escape_register[1]:=1;
      my := wherey + escape_register[1];
      if my > 24 then my:=24;
      gotoxy(wherex,my);
   end;

   procedure
      cursor_right;
   var
      mx  : integer;
   begin
      if escape_register[1]=0 then escape_register[1]:=1;
      mx := wherex + escape_register[1];
      if mx > 80 then mx:=80;
      gotoxy(mx,wherey);
   end;

   procedure
      cursor_left;
   var
      mx  : integer;
   begin
      if escape_register[1]=0 then escape_register[1]:=1;
      mx := wherex - escape_register[1];
      gotoxy(mx,wherey);
   end;

   procedure
      clear_scr;
   begin
      if escape_register[1] = 2 then clrscr;
   end;

   procedure
      clear_line;
   begin
      if escape_register[1] = 0 then clreol;
   end;

   procedure
      escape_wrt;
   var
      i   : integer;
   begin
      for i:=1 to length( escape_str ) do
         wrt( escape_str[i] );
   end;

   procedure
      process_escape( c : char );
   label
      MORE_ESCAPE;
   var
      ch   : char;
   begin
      case c of
         '[','(' : begin
                      escape_type := c;
                      exit;
                   end;
         'm'     : set_graphics;
         'f','H' : addr_cursor;
         'A'     : begin
                      if vt100_mode[1]='F' then goto MORE_ESCAPE;
                      cursor_up;
                   end;
         'B'     : begin
                      if escape_type = '(' then
                         line_drawing_chars := false
                      else begin
                         if vt100_mode[1]='F' then goto MORE_ESCAPE;
                         cursor_down;
                      end;
                   end;
         'C'     : begin
                      if vt100_mode[1]='F' then goto MORE_ESCAPE;
                      cursor_right;
                   end;
         'D'     : begin
                      if vt100_mode[1]='F' then goto MORE_ESCAPE;
                      cursor_left;
                   end;
         '0'     : begin
                      if escape_type <> '(' then goto MORE_ESCAPE;
                      line_drawing_chars := true;
                   end;
         'J'     : clear_scr;
         'K'     : clear_line;
         ^N      : play( escape_str + ' ' );
         ' '     : exit;
      else
         goto MORE_ESCAPE;
      end;
      escape_mode := false;
      exit;
   MORE_ESCAPE:
      ch := upcase( c );
      escape_str := escape_str + ch;
      if ch in [ 'A'..'G','L'..'P' ] then exit;
      if ch in [ '0'..'9' ] then begin
         escape_register[escape_number] := (escape_register[escape_number] * 10) + ord( ch ) - ord( '0' );
         exit;
      end;
      case ch of
         ';', ',' : begin
                       escape_number := escape_number + 1;
                       escape_register[escape_number] := 0;
                    end;
         'T', 'S', '#', '+', '-', '>', '<', '.'
                  : ;
      else
         escape_mode := false;
         escape_wrt;
      end;
   end;

(****************************************************************************)
(*                             SCREEN HANDLER                               *)
(****************************************************************************)
   procedure
      scrwrite( var c : char );
   begin
      if monitor_mode then begin
         if c < ' ' then begin
            prt_cap( '^' );
            prt_cap( chr( ord( c ) + 64 ) );
         end
         else
            prt_cap( c );
         write( c );
      end
      else begin
         if c = ESC then begin
            if escape_mode then escape_wrt;
            escape_str := '';
            escape_number := 1;
            escape_register[1] := 0;
            escape_mode := true;
         end
         else
            if escape_mode then
               process_escape( c )
            else
               wrt( c );
      end;
   end;

(****************************************************************************)
(*                       COMMUNICATIONS PROBLEMS !!!                        *)
(****************************************************************************)
   procedure
      ask_operator(var ch : char);
   begin
      mkwin(60,18,80,22,'');
      error_count := 0;
      writeln;
      write(' Continue? y/n ');
      readln(yes_no);
      yes_no := upcase(yes_no[1]);
      if yes_no[1] = 'Y' then
         ch := NAK
      else begin
         ch := CAN;
         continue_transfer := false;
      end;
      rmwin;
   end;

(****************************************************************************)
(*                              SEND BLOCK                                  *)
(****************************************************************************)
   procedure
      xmit_data(data_block : strtype);
   var
      i         : integer;
   begin
      i := 0;
      while ( i < length(data_block) ) and continue_transfer do begin
         i := i+1;
         store_sout_buffer(data_block[i]);
         if keypressed then begin
            read(kbd,kbd_char);
            ask_operator(kbd_char);
         end;
      end;
      sin_read_ptr := sin_store_ptr;         { Flush the buffer. }
   end;

(****************************************************************************)
(*                             RECEIVE BLOCK                                *)
(****************************************************************************)
   procedure
      recv_data(var data_block : strtype; char_cnt : integer);
   var
      cnt      : integer;
      time     : integer;
      max_loop : byte;
   begin
      data_block := '';
      cnt := 0;
      time := wait_increment;
      max_loop := 40;
      repeat
         if cnt > 0 then
            delay(time);
         if sin_store_ptr <> sin_read_ptr then begin
            data_block := data_block + read_sin_buffer;
            cnt := 0;
            time := sync_time;
            max_loop := 5;
         end
         else
            cnt := cnt + 1;
         if keypressed then begin
            read(kbd,kbd_char);
            ask_operator(kbd_char);
         end;
      until ( cnt > max_loop )
         or ( char_cnt = length(data_block) )
         or ( not continue_transfer );
   end;

(****************************************************************************)
(*                             SYNC WITH REMOTE                             *)
(****************************************************************************)
   procedure
      sync_with_remote;
   begin
      sout_read_ptr := sout_store_ptr;
      delay(sync_time);
      while sin_read_ptr <> sin_store_ptr do begin
         sin_read_ptr := sin_store_ptr;
         delay(sync_time);
         delay(sync_time);
      end;
   end;
   procedure
      sync_NAK;
   var
      i   : integer;
   begin
      for i:=1 to 20 do sync_with_remote;
   end;

(****************************************************************************)
(*                       PROCESS XMODEM INPUT BUFFER                        *)
(****************************************************************************)
   procedure
      process_xmodem_buffer(var xbuf : strtype; var resp : char);
   label
      SEND_NAK;
   var
      i      : integer;
      chk    : integer;
      xcnt   : integer;
   begin
      if length(xbuf) <> 132 then
         goto SEND_NAK;
      if xbuf[1] <> SOH then
         goto SEND_NAK;
      if (ord(xbuf[2]) <> ( ord(xbuf[3]) xor $FF) ) then
         goto SEND_NAK;
      if lo(block_count) = ord(xbuf[2]) then begin
         resp := ACK;
         exit;
      end;
      if lo(block_count + 1) <> ord(xbuf[2]) then
         goto SEND_NAK;
      chk := 0;
      xcnt := xmodem_buf_cnt + 1;
      for i:=4 to 131 do begin
         chk := chk + ord(xbuf[i]);
         xmodem_table_ptr^[xcnt,i-3] := xbuf[i];
      end;
      if lo(chk) <> ord(xbuf[132]) then
         goto SEND_NAK;
      block_count := block_count + 1;
      xmodem_buf_cnt := xmodem_buf_cnt + 1;
      if xmodem_buf_cnt = max_xmodem_buffers then begin
         blockwrite(recv_file,xmodem_table_ptr^,max_xmodem_buffers);
         xmodem_buf_cnt := 0;
      end;
      resp := ACK;
      exit;
   SEND_NAK:
      error_count := error_count + 1;
      if error_count > 30 then
         ask_operator(resp)
      else
         resp := NAK;
      sync_NAK;
   end;

(****************************************************************************)
(*                             RECEIVE FILE                                 *)
(****************************************************************************)
   procedure
      display_headings;
   begin
      clreol;
      writeln;
      writeln('    Block Count    Error Count     Time');
      writeln('    -----------    -----------   --------');
   end;
   procedure
      display_counts( y : integer );
   begin
      curr_time := time;
      gotoxy(8,y);
      write(block_count:4);
      gotoxy(24,y);
      write(error_count:2);
      gotoxy(34,y);
      curr_time := time;
      writeln(delta_time(start_time,curr_time));
   end;
   procedure
      receive_file;
   var
      buf          : strtype;
      response     : char;
   begin
      xmodem_buf_cnt := 0;
      error_count := 0;
      block_count := 0;
      continue_transfer := true;
      mkwin(15,4,62,12,'Receive XMODEM');
      write(' Enter Filename to Receive: ');
      readln(filename);
      if length(filename)=0 then begin
         rmwin;
         exit;
      end;
      setserial(baud,stopbits,8,0);
      assign(recv_file,filename);
      rewrite(recv_file);
      display_headings;
      start_time := time + ' ';
      sync_with_remote;
      store_sout_buffer( NAK );        { NAK the sender to start things off. }
      recv_data(buf,132);              { Get the 1st block from sender.      }
      while ( buf <> CAN )
        and ( buf <> EOT )
        and ( continue_transfer )
      do begin
         process_xmodem_buffer(buf,response);
         if continue_transfer then begin
            display_counts( 5 );
            sync_with_remote;
            store_sout_buffer( response );
            recv_data(buf,132);
         end;
      end;
      sync_with_remote;
      if not continue_transfer then begin
         store_sout_buffer( CAN );
         buf := CAN;
      end;
      if xmodem_buf_cnt > 0 then
         blockwrite(recv_file,xmodem_table_ptr^,xmodem_buf_cnt);
      close(recv_file);
      setserial(baud,stopbits,databits,par);
      if buf = CAN then
         writeln(' File transfer canceled!')
      else begin
         store_sout_buffer( ACK );
         writeln(' File transfer complete.');
      end;
      wait_for_key;
      rmwin;
   end;

(****************************************************************************)
(*                            ALLOCATE BUFFERS                              *)
(****************************************************************************)
   procedure
      get_buffer( var final : boolean );
   begin
      if xmodem_buf_cnt = 0 then begin
         xmodem_rd := 1;
         while ( xmodem_buf_cnt < max_xmodem_buffers ) and ( xmodem_rd <> 0 )
         do begin
            xmodem_buf_cnt := xmodem_buf_cnt + 1;
            blockread(xmit_file,xmodem_table_ptr^[xmodem_buf_cnt],1,xmodem_rd);
         end;
         xmodem_ptr := 0;
      end;
      xmodem_ptr := xmodem_ptr + 1;
      xmodem_buf_cnt := xmodem_buf_cnt - 1;
      if ( xmodem_buf_cnt = 0 ) and ( xmodem_rd = 0 ) then
         final := true
      else
         final := false;
   end;

(****************************************************************************)
(*                    FORMAT XMODEM OUTPUT BUFFER                           *)
(****************************************************************************)
   procedure
      build_xmodem_buffer(var xbuf : strtype; var last_block : boolean);
   var
      i       : integer;
      chk     : integer;
      ch      : char;
   begin
      get_buffer( last_block );
      xbuf := SOH + chr(lo(block_count)) + chr(lo(block_count) xor $FF);
      chk := 0;
      for i:=1 to 128 do begin
         ch := xmodem_table_ptr^[xmodem_ptr,i];
         xbuf := xbuf + ch;
         chk := chk + ord( ch );
      end;
      xbuf := xbuf + chr(lo(chk));
   end;

(****************************************************************************)
(*                        GET REMOTE RESPONSE                               *)
(****************************************************************************)
   procedure
      get_response(var resp : char);
   var
      cnt          : integer;
      answer_back  : string[10];
   begin
      cnt := 0;
      repeat
         recv_data(answer_back,1);
         cnt := cnt + 1;
      until ( cnt = 3 ) or ( answer_back <> '' );
      if ( answer_back[1] = CAN ) or ( answer_back = '' ) then begin
         continue_transfer := false;
         resp := CAN;
      end
      else
         resp := answer_back[1];
   end;

(****************************************************************************)
(*                            TRANSMIT FILE                                 *)
(****************************************************************************)
   procedure
      transmit_file;
   var
      buf          : strtype;
      response     : char;
      cnt          : integer;
      last_block   : boolean;
   begin
      error_count := 0;
      mkwin(15,4,62,13,'Transmit XMODEM');
      repeat
         write(' Enter Filename to Transmit: ');
         readln(filename);
         if length(filename)=0 then begin
            rmwin;
            exit;
         end;
         assign(xmit_file,filename);
         {$I-}
         reset(xmit_file);
         {$I+}
         ok := (ioresult = 0);
         if not ok then
            writeln(' Cannot find file: ',filename);
      until ok;
      setserial(baud,stopbits,8,0);
      writeln(' Files Size is ',filesize(xmit_file)+1,' Blocks.');
      xmodem_buf_cnt := 0;
      block_count := 1;
      build_xmodem_buffer(buf,last_block);
      continue_transfer := true;
      start_time := time;
      xmit_data('Holding for start of transfer...'+CRLF);
      writeln(' Waiting for start... ');
      writeln;
      get_response(response);
      if response <> CAN then begin
         sync_with_remote;
         xmit_data(buf);
         get_response(response);
         gotoxy(1,3);
         display_headings;
         display_counts( 6 );
      end;
      while ( response <> EOT )
        and ( response <> CAN )
        and ( continue_transfer )
      do begin
         sync_with_remote;
         case response of
            NAK : begin
                     error_count := error_count + 1;
                     if error_count > 30 then
                        ask_operator(response);
                     sync_NAK;
                     if continue_transfer then begin
                        xmit_data(buf);
                        get_response(response);
                     end;
                  end;
            ACK : begin
                     if last_block then
                        response := EOT
                     else begin
                        block_count := block_count + 1;
                        build_xmodem_buffer(buf,last_block);
                        xmit_data(buf);
                        get_response(response);
                     end;
                  end;
         else
            response := NAK;
            error_count := error_count + 1;
         end;
         display_counts( 6 );
      end;
      sync_with_remote;
      if not continue_transfer then begin
         store_sout_buffer( CAN );
         response := CAN;
      end
      else begin
         cnt := 0;
         repeat
            store_sout_buffer( EOT );
            get_response(response);
            cnt := cnt + 1;
         until ( response = ACK ) or ( response = CAN ) or ( cnt = 5 );
      end;
      close(xmit_file);
      setserial(baud,stopbits,databits,par);
      if response = CAN then
         writeln(' File transfer canceled!')
      else
         writeln(' File transmission complete.');
      wait_for_key;
      rmwin;
   end;

(****************************************************************************)
(*                                H E L P                                   *)
(****************************************************************************)
   procedure
      give_help;
   begin
      mkwin(31,1,75,24,'Commands, with ALT');
      writeln;
      writeln('    T = Terminate and return to DOS.');
      writeln('    R = Receive using XMODEM protocol.');
      writeln('    X = Transmit using XMODEM protocol.');
      writeln('    A = Transmit using ASCII XON/XOFF.');
      writeln('    C = Toggle capture mode ON/OFF.');
      writeln('    L = Display the disk directory.');
      writeln('    N = New directory and/or drive.');
      writeln('    V = View file.   K = Kill file.');
      writeln('    Y = Copy file.   M = Macro key defs.');
      writeln('    H = Help menu.   I = Change config.');
      writeln('    U = Used time.   F = Fix time.');
      writeln('    S = Change communication parameters.');
      writeln('    D = Modem and dialing management.');
      writeln('    O = Order the dialing directory.');
      writeln('    G = Redial the last number.');
      writeln('    E = Toggle between FULL/HALF duplex.');
      writeln('    Q = Hang up.  ^PrtSc = Toggle printer.');
      writeln('    W = Wipe the screen, clear it.');
      writeln('    P = Put a nickel in the jukebox.');
      writeln;
      wait_for_key;
      rmwin;
   end;

(****************************************************************************)
(*                       RECONFIGURE SYSTEM DEFAULTS                        *)
(****************************************************************************)
   procedure
      change_default( k : integer );
   begin
      gotoxy(29,k+1);
      case k of
         1 : num_input(default_stopbits);
         2 : num_input(default_databits);
         3 : begin
                str_input(parity_ch);
                parity_ch := upcase( parity_ch[1] );
                case parity_ch of
                   'N' : default_parity := 0;
                   'E' : default_parity := 1;
                   'O' : default_parity := 2;
                end;
             end;
         4 : num_input(default_baud);
         5 : num_input(wait_increment);
         6 : str_input(dial_pre_str);
         7 : str_input(dial_post_str);
         8 : str_input(modem_init_str);
         9 : str_input(speaker_on);
        10 : str_input(speaker_off);
        11 : num_input(redial_time);
        12 : str_input(forced_carrier);
        13 : num_input(carrier_timeout);
        14 : begin
                str_input(dial_PATH);
                if dial_PATH[length(dial_PATH)] <> '\' then
                   dial_PATH := dial_PATH + '\';
             end;
        15 : num_input(XON);
        16 : num_input(XOFF);
        17 : str_input(vt100_mode);
      end;
   end;

   procedure
      reconfigure_defaults;
   var
      i   : integer;
      ds  : string10;
      chg : boolean;
   begin
      chg := false;
      mkwin(6,2,75,23,'Reconfigure.  Use: | for CR, ~ for delay.');
      writeln;
      writeln('  1. Number of Stopbits ... ',default_stopbits);
      writeln('  2. Number of Databits ... ',default_databits);
      write  ('  3. Parity Type .......... ');
      case default_parity of
         0 : parity_ch := 'N';
         1 : parity_ch := 'E';
         2 : parity_ch := 'O';
      end;
      writeln(parity_ch);
      writeln('  4. Baud Rate ............ ',default_baud);
      writeln('  5. Time Base ............ ',wait_increment);
      writeln('  6. Dial Pre-String ...... ',dial_pre_str);
      writeln('  7. Dial Post-String ..... ',dial_post_str);
      writeln('  8. Modem Init String .... ',modem_init_str);
      writeln('  9. Speaker-On String .... ',speaker_on);
      writeln(' 10. Speaker-Off String ... ',speaker_off);
      writeln(' 11. Time Until Redial .... ',redial_time);
      writeln(' 12. Forced Carrier ....... ',forced_carrier);
      writeln(' 13. Carrier Timeout ...... ',carrier_timeout);
      writeln(' 14. Directory PATH ....... ',dial_PATH);
      writeln(' 15. XON char, decimal .... ',XON);
      writeln(' 16. XOFF char, decimal ... ',XOFF);
      writeln(' 17. VT100 Mode ........... ',vt100_mode);
      writeln;
      write  (' Enter the number to change or RETURN to exit: ');
      repeat
         gotoxy(48,20);
         clreol;
         read(ds);
         i:=bval(ds+' ');
         if i in [ 1..17 ] then begin
            chg := true;
            change_default(i);
         end
         else
            i:=0;
      until i=0;
      if chg then begin
         upstring(forced_carrier);
         upstring(dial_PATH);
         upstring(speaker_on);
         upstring(speaker_off);
         upstring(dial_pre_str);
         upstring(dial_post_str);
         upstring(modem_init_str);
         upstring(vt100_mode);
         assign(textfile,cnf_PATH+'TMODEM.CNF');
         rewrite_config_file;
         close(textfile);
      end;
      if vt100_mode[1]='T' then silent_mode:=true;
      rmwin;
   end;